SGI Freeware 1999 August/SGI Freeware 1999 August.iso/dist/fw_xemacs.idb/usr/freeware/lib/xemacs-20.4/lisp/utils/pretty-print.el.z/pretty-print.el

Text File | 1998-05-21 | 18.6 KB | 568 lines

;;   -*- Syntax: Emacs-Lisp; Mode: emacs-lisp -*-
;;
;; Emacs Lisp pretty printer and macro expander
;;
;; Copyright (C) 1992,1993 Guido Bosch <[e-mail]>

;; This file is written in GNU Emacs Lisp, but is not part of GNU Emacs.

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with:  Not in FSF.

;; Please send bugs and comments to the author.
;;
;; <DISCLAIMER>
;; This program is still under development.  Neither the author nor
;; CRIN-INRIA accepts responsibility to anyone for the consequences of
;; using it or for whether it serves any particular purpose or works
;; at all.
;;
;; The package has been developed under Lucid Emacs 19, but also runs
;; on Emacs 18, if it is compiled with the version 19 byte compiler
;; (function `compiled-function-p' lacking).
;;

;; Installation and Usage
;; ----------------------
;;
;; This package provides an Emacs Lisp sexpression pretty printer and
;; macroexpander.  To install it, put the following line in your .emacs,
;; default.el or site-init.el/site-run.el (for Lucid Emacs):
;; (require 'pp)
;;
;; The package can also be made autoloadable, with the following entry
;; points:
;; (autoload 'pp-function "pp" nil t)
;; (autoload 'pp-variable "pp" nil t)
;; (autoload 'pp-plist     "pp" nil t)
;; (autoload 'macroexpand-sexp "pp" nil t)
;; (autoload 'macroexpand-all-sexp "pp" nil t)
;; (autoload 'prettyexpand-sexp "pp" nil t)
;; (autoload 'prettyexpand-all-sexp "pp" nil t)
;;
;;(define-key emacs-lisp-mode-map '(control meta m) 'macroexpand-sexp)
;;(define-key emacs-lisp-mode-map '(control meta M) 'macroexpand-all-sexp)
;;(define-key emacs-lisp-mode-map '(control symbol m) 'prettyexpand-sexp)
;;(define-key emacs-lisp-mode-map '(control symbol M) 'prettyexpand-all-sexp)
;;
;;(define-key lisp-interaction-mode-map '(control meta m) 'macroexpand-sexp)
;;(define-key lisp-interaction-mode-map '(control meta M) 'macroexpand-all-sexp)
;;(define-key lisp-interaction-mode-map '(control symbol m) 'prettyexpand-sexp)
;;(define-key lisp-interaction-mode-map '(control symbol M) 'prettyexpand-all-sexp)
;;

;; Pretty printing of the different cells of a symbol is done with the
;; commands:
;;
;;         M-x pp-function
;;         M-x pp-variable
;;        M-x pp-plist
;;
;; They print a symbol's function definition, variable value and
;; property list, respectively.  These commands pop up a separate
;; window in which the pretty printed lisp object is displayed.
;; Completion for function and variable symbols is provided. If a
;; function is byte compiled, `pp-function' proposes to call the Emacs
;; Lisp disassembler (this feature only works for Emacs 19, as it
;; needs the `compiled-function-p' predicate).
;;
;; To use the macro expander, put the cursor at the beginning of the
;; form to be expanded, then type
;;
;;             C-M-m         (macroexpand-sexp)
;; or        C-M-Sh-M      (macroexpand-all-sexp)
;;
;; Both commands will pop up a temporary window containing the
;; macroexpanded code. The only difference is that the second command
;; expands recursively all containing macro calls, while the first one
;; does it only for the uppermost sexpression.
;;     With a prefix argument, the macro expansion isn't displayed in a
;; separate buffer but replaces the original code in the current
;; buffer. Be aware: Comments will be lost.
;;     You can get back the original sexpression using the `undo'
;;     command on `C-x u'.
;;
;; There is also a prettyfied version of the macroexpander:
;;
;;        C-Sym-m        (prettyexpand-sexp)
;; or        C-Sym-M        (prettyexpand-all-sexp)
;;
;; The only difference with the corresponding macroexpand commands is
;; that calls to macros specified in the variable
;; `pp-shadow-expansion-list' are not expanded, in order to make the
;; code look nicer. This is only useful for Lucid Emacs or code that
;; uses Dave Gillespies cl package, as it inhibits expansion of the
;; following macros: block, eval-when, defun*, defmacro*, function*,
;; setf.

; Change History
;
; $Log: pp.el,v $
; Revision 1.4  1993/03/25  14:09:52  bosch
; Commands `prettyexpand-sexp' and `prettyexpand-all-sexp' and
; corresponding key bindings added.  Commands pp-{function, variable}
; rewritten. `pp-plist' added. Function `pp-internal-loop' (for Dave
; Gillespies CL loop macro) added.
;
; Revision 1.3  1993/03/03  12:24:13  bosch
; Macroexpander rewritten. Function `pp-macroexpand-all' added (snarfed
; from Dave Gillespies cl-extra.el). Pretty printing for top level
; defining forms added (`pp-internal-def'). Key bindings for
; `emacs-lisp-mode-map' and `lisp-interaction-mode-map' added.  Built-in
; variable `print-gensym' set for printinng uninterned symbols. Started
; adding support for cl-dg (defun*, defmacro*, ...).  Minor bug fixes.
;
; Revision 1.2  1993/02/25  17:35:02  bosch
; Comments about Emacs 18 compatibility added.
;
; Revision 1.1  1993/02/25  16:55:01  bosch
; Initial revision
;
;


;; TO DO LIST
;; ----------
;; Provide full Emacs 18 compatibility.

;; Popper support
(defvar pp-buffer-name "*Pretty Print*")
(defvar pp-macroexpand-buffer-name "*Macro Expansion*")
(if (featurep 'popper)
    (or (eq popper-pop-buffers 't)
    (setq popper-pop-buffers
          (cons pp-buffer-name
            (cons pp-macroexpand-buffer-name
              popper-pop-buffers)))))

;; User level functions
;;;###autoload
(defun pp-function (symbol)
  "Pretty print the function definition of SYMBOL in a separate buffer"
  (interactive
   (list (pp-read-symbol 'fboundp "Pretty print function definition of: ")))
  (if (compiled-function-p (symbol-function symbol))
      (if (y-or-n-p
       (format "Function %s is byte compiled. Disassemble? " symbol))
      (disassemble (symbol-function symbol))
    (pp-symbol-cell symbol 'symbol-function))
    (pp-symbol-cell symbol 'symbol-function)))

;;;###autoload
(defun pp-variable (symbol)
  "Pretty print the variable value of SYMBOL in a separate buffer"
  (interactive
   (list (pp-read-symbol 'boundp "Pretty print variable value of: ")))
  (pp-symbol-cell symbol 'symbol-value))

;;;###autoload
(defun pp-plist (symbol)
  "Pretty print the property list of SYMBOL in a separate buffer"
  (interactive
   (list (pp-read-symbol 'symbol-plist "Pretty print property list of: ")))
  (pp-symbol-cell symbol 'symbol-plist))

(defun pp-read-symbol (predicate prompt)
  "Read a symbol for which  PREDICATE is true, promptiong with PROMPT."
  (let (symbol)
    (while (or (not symbol) (not (funcall predicate symbol)))
      (setq symbol
        (intern-soft
         (completing-read
          prompt
          obarray
          predicate
          t
          (and symbol (symbol-name symbol))))))
    symbol))

(defun pp-symbol-cell (symbol accessor)
  "Pretty print the contents of the cell of SYMBOL that can be reached
with the function ACCESSOR."
  (with-output-to-temp-buffer pp-buffer-name
    (set-buffer pp-buffer-name)
    (emacs-lisp-mode)
    (erase-buffer)
    (pp-internal
     (funcall accessor symbol)
     (format "%s's %s is:\n" symbol accessor))
    (terpri)))



;; Macro expansion (user level)

;;;###autoload
(defun macroexpand-sexp (&optional replace)
  "Macro expand the sexpression following point. Pretty print expansion in a
temporary buffer. With prefix argument, replace the original
sexpression by its expansion in the current buffer."
  (interactive "P")
  (pp-macroexpand-internal 'macroexpand replace t))

;;;###autoload
(defun macroexpand-all-sexp (&optional replace)
  "Macro expand recursively the sexpression following point. Pretty print
expansion in a temporary buffer. With prefix argument, replace the
original sexpression by its expansion in the current buffer."
  (interactive "P")
  (pp-macroexpand-internal 'pp-macroexpand-all replace t))

;;;###autoload
(defun prettyexpand-sexp (&optional replace)
  "Macro expand the sexpression following point. Pretty print expansion
in a temporary buffer. With prefix argument, replace the original
sexpression by its expansion in the current buffer.
    However, calls to macros specified in the variable
`pp-shadow-expansion-list' are not expanded, in order to make the code
look nicer."

  (interactive "P")
  (pp-macroexpand-internal 'macroexpand replace))

;;;###autoload
(defun prettyexpand-all-sexp (&optional replace)
  "Macro expand recursively the sexpression following point. Pretty print
expansion in a temporary buffer. With prefix argument, replace the
original sexpression by its expansion in the current buffer.
    However, calls to macros specified in the variable
`pp-shadow-expansion-list' are not expanded, in order to make the code
look nicer."
  (interactive "P")
  (pp-macroexpand-internal 'pp-macroexpand-all replace))

;; XEmacs: don't do this at load time.
;;(define-key emacs-lisp-mode-map '(control meta m) 'macroexpand-sexp)
;;(define-key emacs-lisp-mode-map '(control meta M) 'macroexpand-all-sexp)
;;(define-key emacs-lisp-mode-map '(control symbol m) 'prettyexpand-sexp)
;;(define-key emacs-lisp-mode-map '(control symbol M) 'prettyexpand-all-sexp)

;;(define-key lisp-interaction-mode-map '(control meta m) 'macroexpand-sexp)
;;(define-key lisp-interaction-mode-map '(control meta M) 'macroexpand-all-sexp)
;;(define-key lisp-interaction-mode-map '(control symbol m) 'prettyexpand-sexp)
;;(define-key lisp-interaction-mode-map '(control symbol M) 'prettyexpand-all-sexp)


;; Macro expansion (internals)

(defvar pp-shadow-expansion-list
  (mapcar 'list '(block eval-when defun* defmacro* function* setf))
  "The value of this variable is given as the optional environment
argument of the macroexpand functions. Forms specified in this list are
not expanded.")

(defun pp-macroexpand-internal
  (macroexpand-function replace &optional dont-shadow)
  "Macro expand the sexp that starts at point, using
MACROEXPAND-FUNCTION.  If REPLACE is non-nil, replace the original
text by its expansion, otherwise pretty print the expansion in a
temporary buffer. With optional argument DONT-SHADOW non-nil, do not
use the `pp-shadow-expansion-list' to inhibit expansion of some
forms."

  (interactive)
  (let ((expansion
     (funcall
      macroexpand-function
      (let ((stab (syntax-table)))
        (unwind-protect
        (save-excursion
          (set-syntax-table emacs-lisp-mode-syntax-table)
          ;; (forward-sexp 1)
          (read (current-buffer)))
          (set-syntax-table stab)))
      (if dont-shadow
          nil
        pp-shadow-expansion-list))))
    (save-excursion
      (if replace
      (let ((start (point))
        (end (progn (forward-sexp 1) (point))))
        (delete-region start end)
        (pp-internal expansion))
    (with-output-to-temp-buffer pp-macroexpand-buffer-name
      (set-buffer pp-macroexpand-buffer-name)
      (erase-buffer)
      (emacs-lisp-mode)
      (pp-internal expansion))))))

;; Internal pretty print functions

(defun pp-internal (form &optional title)
  "Pretty print FORM in in the current buffer.
Optional string TITEL is inserted before the pretty  print."
  (let (start)
    (if title (princ title))
    (setq start (point))
    ;; print-escape-newlines must be t, otherwise we cannot use
    ;; (current-column) to detect good line breaks
    (let ((print-escape-newlines t)
      (print-gensym t)
      )
      (prin1 form (current-buffer))
      (goto-char start)
      (pp-internal-sexp))))

(defun pp-internal-sexp ()
  "Pretty print the following sexp.
Point must be on or before the first character."

  (skip-chars-forward " \n\t")
  (let* ((char (following-char))
     (ch-class (char-syntax char))
     (start (point)))

    (cond
     ;; open paren
     ((eq char ?\()
      (down-list 1)
      (if (memq  (char-syntax (following-char)) '(?_ ?w))
      (let ((symbol (read (current-buffer))))
        (cond ((fboundp symbol)
           (goto-char start)
           (pp-internal-function symbol))
          ((memq symbol '(lambda macro))
           (pp-internal-lambda))
          (t
           (goto-char start)
           (pp-internal-list))))
    (up-list -1)
    (pp-internal-list)))

     ;;symbols & strings
     ((memq  ch-class '(?_        ; symbol
            ?w        ; word
            ?\"        ; string
            ?\\        ; escape
            ?\'        ; quote (for uninterned symbols)
            )) (forward-sexp 1))

     ;; vector
     ((eq char ?\[) (pp-internal-list))

     ;; error otherwise
     (t (error "pp-internal-sexp: character class not treated yet: `%c'"
           ch-class)))))

(defun pp-internal-function (func)
  "Pretty print a functuion call.
Point must be on the open paren. the function symbol may be passed as an
optional argument."
  (let ((start (point))
    (too-large (>= (save-excursion
             (forward-sexp 1)
             (current-column))
               fill-column))
    (indent-info (get func lisp-indent-function)))
    (down-list 1)
    ;; skip over function name
    (forward-sexp 1)
    (cond
     ((memq func '(let let*)) (pp-internal-let))

     ((eq func 'cond) (pp-internal-cond))

     ((memq func '(if while with-output-to-temp-buffer catch block))
      (pp-internal-sexp)
      (pp-internal-body 't))

     ((eq func 'quote) (pp-internal-quote))

     ((memq func '(progn
            prog1 prog2
            save-window-excursion
            save-excursion
            save-restriction))
      (pp-internal-body 't))

     ((memq func '(defun defmacro defsubst defun* defmacro*))
      (pp-internal-def))

     ((eq func 'loop) (pp-internal-loop))

     ('t (pp-internal-body too-large)))))

(defun pp-internal-def ()
  (forward-sexp 1)            ; skip name
  (if (looking-at " nil")        ; replace nil by ()
      (replace-match " ()")
    (forward-sexp 1))
  (if (looking-at " \"")
      ;; comment string. Replace all escaped linefeeds by real ones
      (let ((limit (save-excursion (forward-sexp 1) (point-marker))))
    (newline-and-indent)
    (while (re-search-forward "\\\\n" limit t)
      (replace-match "\n" nil nil))
    (goto-char limit)))
  (pp-internal-body 't))

(defun pp-internal-list ()
  "Pretty print a list  or a vector.
Point must be on the open paren."
  (let ((too-large (>= (save-excursion
            (forward-sexp 1)
            (current-column))
              fill-column)))
    (down-list 1)
    (pp-internal-sexp)
    (pp-internal-body too-large)))

(defun pp-internal-body (&optional force-indent)
  "Prety print a body of sexp. Stop after reaching a `)'.  If argument
FORCE-INDENT is non-nil, break line after each sexpression of the
body."
  (skip-chars-forward " \n\t")
  (let (ch-class)
    ;; while not closing paren
    (while (/= (setq ch-class (char-syntax (following-char))) ?\))
      (if  force-indent (newline-and-indent))
      (pp-internal-sexp))
    (up-list 1)))

(defun pp-internal-loop ()
  "Prety print a loop body. Stop after reaching a `)'.
Line breaks are done before the following keywords: "
  (forward-sexp 1)
  (skip-chars-forward " \n\t")
  (let (ch-class)
    ;; while not closing paren
    (while (/= (setq ch-class (char-syntax (following-char))) ?\))
      (if (not (looking-at "for\\|repeat\\|with\\|while\\|until\\|always\\|never\\|thereis\\|collect\\|append\\|nconc\\|sum\\|count\\|maximize\\|minimize\\|if\\|when\\|else\\|unless\\|do\\W\\|initially\\|finally\\|return\\|named"))
      (pp-internal-sexp)
    (newline-and-indent)
    (forward-sexp 1))
      (skip-chars-forward " \n\t"))
    (up-list 1)))

(defun pp-internal-body-list ()
  (let ((too-large (>= (save-excursion
            (forward-sexp 1)
            (current-column))
              fill-column))
    ch-class)
    (down-list 1)
    (pp-internal-sexp)
    (while (/= (setq ch-class (char-syntax (following-char))) ?\))
      (if  too-large (newline-and-indent))
      (pp-internal-sexp))
    (up-list 1)))

(defun pp-internal-lambda ()
  (forward-sexp 1) ; arguments
  (pp-internal-body 't))

(defun pp-internal-let ()
  "Pretty print a let-like  form.
Cursor is behind funtion symbol."
  (down-list 1)
  (while (not (= (following-char) ?\)))
    (if (= (following-char) ?\()
    (pp-internal-body-list)
      (forward-sexp 1))
    (if (not (= (following-char) ?\)))
        (newline-and-indent)))
  (up-list 1)
  (pp-internal-body 't))

(defun pp-internal-cond ()
  "Pretty print a cond-like  form.
Cursor is behind funtion symbol."
  (skip-chars-forward " \n\t")
  (while (not (= (following-char) ?\)))
    (pp-internal-body-list)
    (if (not (= (following-char) ?\)))
    (newline-and-indent)))
  (up-list 1))


(defun pp-internal-quote ()
  "Pretty print a quoted list.
Cursor is behind the symbol quote."
  (skip-chars-forward " \n\t")
  (let ((end (point)))
    (backward-sexp 1)
    (delete-region (point) end)
    (up-list -1)
    (setq end (point))
    (forward-sexp 1)
    (delete-char -1)
    (goto-char end)
    (delete-char 1)
    (insert "'")
    (if (= (char-syntax (following-char)) ?\()
    ;; don't print it as sexp, because it could be (let ... ) or
    ;; (cond ... ) or whatever.
    (pp-internal-list)
      (pp-internal-sexp))))


;; Stolen form Dave Gillespies cl-extra.el
(defun pp-macroexpand-all (form &optional env)
  "Expand all macro calls through a Lisp FORM.
This also does some trivial optimizations to make the form prettier."
  (setq form (macroexpand form env))
  (cond
   ((not (consp form)) form)
   ((memq (car form) '(let let*))
    (if (null (nth 1 form))
    (pp-macroexpand-all (cons 'progn (cdr (cdr form))) env)
      (cons (car form)
        (cons (pp-macroexpand-lets (nth 1 form) env)
          (pp-macroexpand-body (cdr (cdr form)) env)))))
   ((eq (car form) 'cond)
    (cons (car form)
      (mapcar (function (lambda (x) (pp-macroexpand-body x env)))
          (cdr form))))
   ((eq (car form) 'condition-case)
    (cons (car form)
      (cons (nth 1 form)
        (cons (pp-macroexpand-all (nth 2 form) env)
              (pp-macroexpand-lets
               (cdr (cdr (cdr form))) env)))))
   ((memq (car form) '(quote function))
    (if (eq (car-safe (nth 1 form)) 'lambda)
    (list (car form)
          (cons 'lambda
            (cons (car (cdr (car (cdr form))))
              (pp-macroexpand-body
               (cdr (cdr (car (cdr form)))) env))))
      form))
   ((memq (car form) '(defun defmacro))
    (cons (car form)
      (cons (nth 1 form)
        (pp-macroexpand-body (cdr (cdr form)) env))))
   ((and (eq (car form) 'progn) (not (cdr (cdr form))))
    (pp-macroexpand-all (nth 1 form) env))
   (t
    (cons (car form) (pp-macroexpand-body (cdr form) env)))))

(defun pp-macroexpand-body (body &optional env)
  (mapcar (function (lambda (x) (pp-macroexpand-all x env))) body))

(defun pp-macroexpand-lets (list &optional env)
  (mapcar (function
       (lambda (x)
         (if (consp x) (cons (car x) (pp-macroexpand-body (cdr x) env))
           x))) list))

(run-hooks 'pp-load-hook)
(provide 'pp)

;; end pp.el